(ns jna
  (:use [clojure.string :only [join]]
        util.utils)
  (:import [com.sun.jna Library Native Platform Pointer Function NativeLong IntegerType]))

(defn jna-get-function [dll function]
  (Function/getFunction dll function))

(declare to-type)
(defn jna-compile [dll function return]
  (let [fun (jna-get-function dll function)
        return (to-type return)]
    (fn [& args] (.invoke fun return (to-array args)))))

(defmacro defjna [return dll function]
  `(def ~function (jna-compile ~(str dll) ~(str function) ~return)))

(declare is-64bit?)
(defmacro defjna64 [return dll function]
  `(defjna ~return ~(str dll (when (is-64bit?) 64)) ~function))

(defn jna-malloc [size]
  (let [buffer (java.nio.ByteBuffer/allocateDirect size)]
    (.order buffer java.nio.ByteOrder/LITTLE_ENDIAN)))

(defn jna-pointer [buffer]
  (Native/getDirectBufferPointer buffer))

; Native Type	Size	Java Type	Common Windows Types char	8-bit integer	byte	BYTE, TCHAR
; short	16-bit integer	short	WORD
; wchar_t	16/32-bit character	char	TCHAR
; int	32-bit integer	int	DWORD
; int	boolean value	boolean	BOOL
; long	32/64-bit integer	NativeLong	LONG
; long long	64-bit integer	long	__int64
; float	32-bit FP	float
; double	64-bit FP	double
; char*	C string	String	LPTCSTR
; void*	pointer	Pointer	LPVOID, HANDLE, LPXXX

; x64:
; double: 8
; long: 4
; long long: 8
; LONG: 4
; LONGLONG: 8
; PVOID: 8
; HANDLE: 8
; SIZE_T: 8
; LPCSTR: 8
; LPCWSTR: 8
; LPWSTR: 8
; WCHAR: 2

(def os-bits (Integer/parseInt (System/getProperty "sun.arch.data.model")))
(defmacro get-bits []
  `os-bits)
(defn is-64bit? []
  (= (get-bits) 64))
(defn is-32bit? []
  (= (get-bits) 32))
(def native-size (condp = (get-bits) 64 8 32 4)) ; XXX: different from com.sun.jna.NativeLong!
(def native (condp = (get-bits) 64 long 32 int))
(def native-type (condp = (get-bits) 64 Long 32 Integer))
(def native-0 (native 0))

(def NULL Pointer/NULL)

(def padding (condp = (get-bits) 64 8 32 8))
(def padding-steps (take-while #(<= % padding) (iterate #(* 2 %) 1)))
(def padding-rooms (mapcat #(for [i (range 0 padding %)] [i %]) padding-steps))
(defn- find-padding-room [offset size]
  (ffirst (filter (fn [[o s]] (and (<= offset o) (<= size s))) padding-rooms)))
(defn compute-padding-index [index size]
  (let [r (rem index padding)]
    (cond
      (zero? r) index
      (> size padding) (+ index (- padding r))
      (find-padding-room r size) (+ (- index r) (find-padding-room r size))
      :else (+ index (- padding r)))))

(def jna-famous-type {
  :native native-type
  :HWND native-type
  :pointer Pointer
  :HANDLE native-type
  })

(defn- to-type [x]
  (jna-famous-type x x))

(def jna-famous-size {
  :native native-size
  Integer 4
  :char 1
  :double 8
  :BYTE 1
  :WORD 2
  :DWORD 4
  :LONG 4
  :ULONG 4
  :LONGLONG 8
  :pinter native-size
  :PVOID native-size
  :SIZE_T native-size
  :LPCSTR native-size
  :LPCWSTR native-size
  :LPWSTR native-size
  :LPTSTR native-size
  :WCHAR 2
  :HANDLE native-size
  :HWND native-size
  :pointer native-size
  })

(defn jna-size-of [type]
  (cond
    (::size type) (::size type)
    (:size type) (:size type)
    (get jna-famous-size type) (get jna-famous-size type)
    :else (throw (Exception. (str "Don't know the size of " type)))))

(defn jna-buffer-def [{buffer :buffer pointer :pointer offset :offset} index length type]
  (let [index (+ (or offset 0) index)]
    (cond
      (::size type)  {:type type
                      :size (::size type)
                      :buffer buffer
                      :pointer pointer
                      :offset index} ; TODO: if this is an array...
      (= length 4) (.getInt buffer index)
      (= length 8) (.getLong buffer index)
      (= type :WCHAR) (.getChar buffer index)
      :else (throw (Exception. (format "Can only read int and WCHAR field right now. %s is not supported" type))))))

(defn jna-struct [& fields]
  (loop [fields fields
         struct {}
         index 0]
    (if (empty? fields)
      (assoc struct ::size index)
      (let [[type field] (first fields)
            size (jna-size-of type)
            index (compute-padding-index index (or (:element-size type) size))]
        (recur (next fields) (assoc struct field [index size type]) (+ index size))))))

(defmacro def-jna-struct [struct & fields]
  `(def ~struct (jna-struct ~@ fields)))

(defn jna-struct-new [struct]
  (let [type struct
        size (jna-size-of struct)
        buffer (jna-malloc size)
        pointer (jna-pointer buffer)]
    {:type type
     :size size
     :buffer buffer
     :pointer pointer}))

(defn jna-struct-get [field struct]
  (when-not (get (:type struct) field)
    (throw (Exception. (format "Field %s not found in %s (%s)" field struct (:type struct)))))
  (let [[index size type] (get (:type struct) field)
        buffer (:buffer struct)]
    (jna-buffer-def struct index size type)))


(defn jna-union [& fields]
  (loop [fields fields
         union {}
         usize 0]
    (if (empty? fields)
      (assoc union ::size usize)
      (let [[type field] (first fields)
            size (jna-size-of type)]
        (recur (next fields) (assoc union field [size type]) (max usize size))))))

(defmacro def-jna-union [union & fields]
  `(def ~union (jna-union ~@ fields)))

(defn jna-union-new [union]
  (let [type union
        size (jna-size-of union)
        buffer (jna-malloc size)
        pointer (jna-pointer buffer)]
    {:type type
     :size size
     :buffer buffer
     :pointer pointer}))

(defn jna-union-get [field union]
  (when-not (get (:type union) field)
    (throw (Exception. (format "Field %s not found in %s (%s)" field union (:type union)))))
  (let [[size type] (get (:type union) field)
        buffer (:buffer union)]
    (jna-buffer-def union 0 size type)))

(defn jna-array [type size]
  {:element-type type
   :element-size (jna-size-of type)
   :count size
   ::size (* size (jna-size-of type))})

(defn jna-array-new
  ([array]
    (let [type array
          size (jna-size-of array)
          buffer (jna-malloc size)
          pointer (jna-pointer buffer)]
      {:type type
       :size size
       :buffer buffer
       :pointer pointer}))
  ([type size]
    (jna-array-new (jna-array type size))))

(defn jna-array-get [n array]
  (let [array-type (:type array)
        type (:element-type array-type)
        size (:element-size array-type)
        index (* n size)
        buffer (:buffer array)]
    (jna-buffer-def array index size type)))

(defn jna-array-seq
  ([array]
    (jna-array-seq array 0))
  ([array index]
    (when (< index (:count (:type array)))
      (let [e (jna-array-get index array)]
        (lazy-seq
          (cons e (jna-array-seq array (inc index))))))))

(defn jna-array-length [array]
  (:count (:type array)))

(defn jna-new [type]
  (let [size (jna-size-of type)
        buffer (jna-malloc size)
        pointer (jna-pointer buffer)]
    {:type type
     :size size
     :buffer buffer
     :pointer pointer}))

(defn jna-def [v]
  (let [type (:type v)
        size (:size v)
        buffer (:buffer v)]
    (jna-buffer-def v 0 size type)))

(defn jna-to-string ; TODO: not good performance
  ([v start length]
    (join (take length (drop start (jna-array-seq v)))))
  ([v length]
    (jna-to-string v 0 length))
  ([v]
    (jna-to-string v 0 (jna-array-length v))))

(def size-of jna-size-of)
(defn address-of [v] (:pointer v))
(defn byref [v] (address-of v))
(defn byvalue [v] (jna-def v))


;;; JNA using types, just for example...

(defn- qcname [name]
  (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)))

(defn- make-sigs [sigs]
  (let [tag (fn [x] (or (:tag (meta x)) Object))
        psig (fn [[return name [& args]]]
               (vector name (vec (map to-type args)) (to-type return) (map meta args)))]
    (vec (map psig sigs))))

(defmacro extend-interface [name super & sigs]
  (let [cname (qcname name)]
    `(let []
      (gen-interface :name ~cname :extends [~super] :methods ~(make-sigs sigs))
      (import ~cname))))

(defmacro load-library [rtlib & sigs]
  (let [name (gensym (symbol (str 'jna__interface__ rtlib '__)))
        cname (qcname name)]
    `(let []
      (extend-interface ~name com.sun.jna.Library ~@sigs)
      (com.sun.jna.Native/loadLibrary ~rtlib ~cname))))

(defmacro deflib [name rtlib & sigs]
  `(def ~name (load-library ~rtlib ~@sigs)))

(defmacro deflib- [name & sigs]
  `(deflib ~name ~(clojure.core/name name) ~@sigs))

;; XXX: TODO: how to define Object... or Object[]?
;(deflib libc (if (Platform/isWindows) "msvcrt" "c")
;  (void printf [String]))


(def callback-base com.sun.jna.Callback)
(compile-when (Platform/isWindows)
  (def win-callback-base com.sun.jna.win32.StdCallLibrary$StdCallCallback)
  (def callback-base win-callback-base))

(defmacro defcallback [return name args]
  `(extend-interface ~name ~callback-base
    (~return ~'callback [~@args])))

(defmacro callback [type args & body]
  `(proxy [~type] []
    (callback ~args
      ~@body)))


(comment
(let [f (jna-compile "msvcrt" "printf" Integer)]
  (f "%d -> %d" 2 3))
)

(comment
(def-jna-struct SYSTEM_BASIC_INFORMATION
  [:DWORD :dwUnknown1]
  [:ULONG :uKeMaximumIncrement]
  [:ULONG :uPageSize]
  [:ULONG :uMmNumberOfPhysicalPages]
  [:ULONG :uMmLowestPhysicalPage]
  [:ULONG :uMmHighestPhysicalPage]
  [:ULONG :uAllocationGranularity]
  [:PVOID :pLowestUserAddress]
  [:PVOID :pMmHighestUserAddress]
  [:ULONG :uKeActiveProcessors]
  [:BYTE :bKeNumberProcessors]
  [:BYTE :bUnknown2]
  [:WORD :wUnknown3])
)


